home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / evprim.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  27.1 KB  |  747 lines
  1. ;;;-*- mode:lisp;syntax :zetalisp; package: Boxer; fonts: cptfont, cptfontb -*-
  2.  
  3. #|
  4.             Copyright 1985 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                                           +-Data--+
  18.                  This file is part of the | BOXER | system
  19.                                           +-------+
  20.  
  21. This file defines the internal representation for Boxes used by the Evaluator.
  22. We use a different represention for boxes in the Evaluator for the following reasons:
  23.  
  24.    The Evaluator will have to create a large number of Boxes during the course
  25.     of a normal execution.  It is to our advantage to have small objects for boxes
  26.     for both speed (CONSing time) and space considerations.  General purpose Boxes
  27.     are not small and they contain a lot of irrelevant(to the Evaluator) information.
  28.  
  29.    Having a different representation for Boxes also allows us to keep the format of
  30.     the Box in a form that is partially pre-digested for the Evaluator--saving us
  31.     a few more cycles.  
  32.  
  33. The Evaluator representation of a Box is known as an Evbox for Evaluator Box.
  34. Evboxes have the following properties:
  35.  
  36.    Its contents.  The representation of the contents should be in a form that the
  37.     Evaluator can deal with easily(what the reader spits out perhaps).  Spacing information
  38.     is also preserved.
  39.  
  40.    EvPORTS will have a pointer to the target of the port
  41.  
  42.    The name ?
  43.  
  44.    The Local Variable Bindings; 
  45.  
  46. This code is descended from similiar "Pre-box" code written by Mike Eisenberg
  47.  
  48. The Actual Definitions for the structures used here are in the file EVDEFS
  49. |#
  50.  
  51.  
  52.  
  53.  
  54. ;;;; Some predicates
  55.  
  56. (DEFUN BLANK-EV-ROW? (EV-ROW)
  57.   (OR (NULL EV-ROW)
  58.       (NOT (DOLIST (ENTRY EV-ROW) (UNLESS (SPACES? ENTRY) (RETURN T))))))
  59.  
  60. (DEFUN EMPTY-EVROW? (EVROW)
  61.   (OR (NULL EVROW) (NULL (EVROW-ENTRIES EVROW))))
  62.  
  63. (DEFF BLANK-EV-ROW? #'EMPTY-EVROW?)
  64. (COMPILER:MAKE-OBSOLETE BLANK-EV-ROW? "Use EMPTY-EVROW? instead.")
  65.  
  66. (DEFUN EMPTY-EVBOX? (EVBOX)
  67.   (LET ((ROWS (EVBOX-ROWS EVBOX)))
  68.     (OR (NULL ROWS)
  69.     (NOT (DOLIST (ROW ROWS) (UNLESS (EMPTY-EVROW? ROW) (RETURN T)))))))
  70.  
  71.  
  72.  
  73. ;;; HOW to translate Boxes (EDITOR instances) into evaluator objects (EvBoxes) and vice versa
  74.  
  75. ;; make an empty EvBOX
  76. (DEFUN MAKE-EMPTY-EVBOX (&OPTIONAL (TYPE 'DATA-BOX))
  77.   (SELECTQ TYPE
  78.     ((DATA-BOX :DATA-BOX) (MAKE-EVDATA ROWS `(,(MAKE-EVROW))))
  79.     ((DOIT-BOX :DOIT-BOX) (MAKE-EVDOIT ROWS `(,(MAKE-EVROW))))
  80.     ((PORT-BOX :PORT-BOX) (MAKE-EVPORT))    ;will we EVER need to do this ???
  81.     (OTHERWISE (FERROR "Don't know how to make an empty EvBox of type ~A" TYPE))))
  82.  
  83. (DEFUN MAKE-EVROW-FROM-ROW (ROW)
  84.   (MAKE-EVROW ENTRIES (TELL ROW :ENTRIES) ITEMS (TELL ROW :ITEMS)))
  85.  
  86. (DEFUN MAKE-EVROWS-FROM-BOX (BOX)
  87.   (MAPCAR #'MAKE-EVROW-FROM-ROW (TELL BOX :ROWS)))
  88.  
  89. ;; need to flatten out exports here
  90. (defun copy-local-bindings (box)
  91.   (let ((exporting-marker-entry (assq *exporting-box-marker*
  92.                       (TELL BOX :GET-STATIC-VARIABLES-ALIST))))
  93.     (if (null exporting-marker-entry)
  94.     (COPYLIST (TELL BOX :GET-STATIC-VARIABLES-ALIST))
  95.     (nconc (remq exporting-marker-entry (TELL BOX :GET-STATIC-VARIABLES-ALIST))
  96.            (copy-local-bindings (cdr exporting-marker-entry))))))
  97.  
  98. (DEFUN GET-NAME-FOR-EVBOX (BOX)
  99.   (IF (STRING-EQUAL (TELL BOX :NAME) "Un-named") NIL (TELL BOX :NAME)))
  100.  
  101. ;;; Shallow copying for the evaluator
  102.  
  103. (DEFUN COPY-EVBOX (EVBOX)
  104.   "Does a top level copy. Elements are NOT copied"
  105.   (SELECTQ (TYPEP EVBOX)
  106.     ((EVDOIT) (COPY-EVDOIT EVBOX))
  107.     ((EVDATA) (COPY-EVDATA EVBOX))
  108.     ((EVPORT) (COPY-EVPORT EVBOX))
  109.     (T (FERROR "Dont' know how to copy ~A" EVBOX))))
  110.  
  111. ;;; copying no longer flattens boxes down into numbers because the number-box? check 
  112. ;;; is costing us about 2500 microseconds PER COPY (and we are copying EVERYWHERE...)
  113. ;;; This is as opposed to the fact that CONSing up an evbox takes about 380 microseconds
  114. ;;; and getting the template for some function that REALLY wants a number (not that many due
  115. ;;; to the existence of data-box arithmetic) like a turtle function doesn't cost us anything
  116. ;;; cause we got to look for it anyway
  117. (DEFUN SHALLOW-COPY-FOR-EVALUATOR (THING)
  118.   (COND ((NOT (OR (EVAL-BOX? THING) (EVAL-PORT? THING))) THING)    ;non-boxes
  119.     ((OR (GRAPHICS-BOX? THING) (GRAPHICS-DATA-BOX? THING) (SPRITE-BOX? THING))
  120.      ;; a crock to make graphics work
  121.      THING)
  122.     ((BOX? THING) (MAKE-TOP-LEVEL-EVBOX-FROM-BOX THING))    ;editor boxes  ev boxes
  123.     (T (COPY-EVBOX THING))))
  124.  
  125. ;;; This is the same as the above Except that numbers are boxifed instead of number boxes
  126. ;;; being flattened out into numbers
  127. (DEFUN SHALLOW-COPY-FOR-ARGLIST (THING)
  128.   (COND ((NUMBERP THING) (MAKE-EVDATA ROWS `(,(MAKE-EVROW-FROM-ENTRY THING))))    ;numbers  box
  129.     ((NOT (OR (EVAL-BOX? THING) (EVAL-PORT? THING))) THING)    ;anything but boxes
  130.     ((OR (GRAPHICS-BOX? THING) (GRAPHICS-DATA-BOX? THING) (SPRITE-BOX? THING))
  131.      ;; a crock to make graphics work
  132.      THING)
  133.     ((BOX? THING) (MAKE-TOP-LEVEL-EVBOX-FROM-BOX THING))    ;editor boxes
  134.     (T (COPY-EVBOX THING))))
  135.  
  136. ;;; It is useful to set *EVALUATOR-BOX-COPYING-FUNCTION* to this for metering purposes
  137. (DEFUN NO-COPY (BOX)
  138.   BOX)
  139.  
  140. ;; this is the top level function to be called to get an EvBOX
  141.  
  142. (DEFUN MAKE-TOP-LEVEL-EVBOX-FROM-BOX (BOX)
  143.   (MAKE-EVBOX-FROM-BOX BOX NIL))
  144.  
  145. (DEFUN MAKE-EVBOX-FROM-BOX (BOX &OPTIONAL (NAME (GET-NAME-FOR-EVBOX BOX)))
  146.   (CHECK-BOX-ARG BOX)                ;we can take this out later for speed
  147.   (SELECTQ (TYPEP BOX)
  148.     ((DOIT-BOX :DOIT-BOX) (MAKE-EVDOIT ROWS     (MAKE-EVROWS-FROM-BOX BOX)
  149.                        BINDINGS (COPY-LOCAL-BINDINGS BOX)
  150.                        NAME     NAME))
  151.     ((DATA-BOX :DATA-BOX) (MAKE-EVDATA ROWS     (MAKE-EVROWS-FROM-BOX BOX)
  152.                        BINDINGS (COPY-LOCAL-BINDINGS BOX)
  153.                        NAME     NAME))
  154.     ((PORT-BOX :PORT-BOX) (MAKE-EVPORT TARGET (TELL BOX :PORTS)
  155.                        NAME   NAME))
  156.     (OTHERWISE (FERROR "Don't know how to make an Evbox from ~A" BOX))))
  157.  
  158. (DEFUN MAKE-BOX-FROM-EVBOX (EVBOX)
  159.   (SELECTQ (TYPEP EVBOX)
  160.     ((EVDATA EVDOIT) 
  161.      (let ((new-box (MAKE-BOX (EVBOX-ROW-ITEMS EVBOX) :DATA-BOX (EVBOX-NAME EVBOX))))
  162.        (let ((ll (get-evbox-local-library evbox)))
  163.      (when (not (null ll))
  164.        (send new-box :set-local-library ll)
  165.        (send new-box :add-static-variable-pair *exporting-box-marker* ll)
  166.        (send ll :export-all-variables)))
  167.        new-box))
  168.     ((EVPORT) (PORT-TO-INTERNAL (GET-PORT-TARGET EVBOX)))))
  169.  
  170.  
  171.  
  172. ;;;; Stream interface
  173.  
  174. (DEFUN MAKE-ROW-STREAM-FROM-EVROW (EVROW)
  175.   (MAKE-ROW-STREAM `(:ROW . ,(EVROW-ITEMS EVROW))))
  176.  
  177. (DEFUN MAKE-EVDATA-STREAM (EVDATA)
  178.   (MAKE-BOX-STREAM `(:BOX
  179.              (:TYPE :DATA-BOX :DISPLAY-STYLE-LIST (:NORMAL NIL NIL)
  180.               :NAME ,(EVBOX-NAME EVDATA))
  181.              ,@(LOOP FOR ROW IN (EVBOX-ROWS EVDATA)
  182.                  COLLECT (MAKE-ROW-STREAM-FROM-EVROW ROW)))))
  183.  
  184. (DEFUN MAKE-EVDOIT-STREAM (EVDATA)
  185.   (MAKE-BOX-STREAM `(:BOX
  186.              (:TYPE :DOIT-BOX :DISPLAY-STYLE-LIST (:NORMAL NIL NIL)
  187.               :NAME ,(EVBOX-NAME EVDATA))
  188.              ,@(LOOP FOR ROW IN (EVBOX-ROWS EVDATA)
  189.                  COLLECT (MAKE-ROW-STREAM-FROM-EVROW ROW)))))
  190.  
  191. ;; this needs to handle targets which are evboxes (2 cases here: evbox is(not) also returned)
  192. (DEFUN MAKE-EVPORT-STREAM (EVPORT)
  193.   (MAKE-BOX-STREAM (PORT-TO-INTERNAL (EVPORT-TARGET EVPORT))))
  194.  
  195. (DEFPROP EVDATA MAKE-EVDATA-STREAM :MAKE-BOXER-STREAM)
  196. (DEFPROP EVDOIT MAKE-EVDOIT-STREAM :MAKE-BOXER-STREAM)
  197. (DEFPROP EVPORT MAKE-EVPORT-STREAM :MAKE-BOXER-STREAM)
  198.  
  199.  
  200. ;;; This is used to convert the result of BOXER-READ into something 
  201. ;;; the evaluator can deal with
  202. (DEFUN PARSE-LIST-FOR-EVAL (LIST)
  203.   (LOOP FOR ELEMENT IN LIST
  204.     UNTIL (COMMENT-CHA? ELEMENT)
  205.     UNLESS (SPACES? ELEMENT)
  206.       COLLECT (COND ((OR (LABEL-PAIR? ELEMENT) (EVAL-IT-TOKEN? ELEMENT)
  207.                  (UNBOX-TOKEN? ELEMENT))
  208.              ELEMENT)
  209.             ((LISTP ELEMENT) (PARSE-LIST-FOR-EVAL ELEMENT))
  210.             (T ELEMENT))))
  211.  
  212. (DEFUN TOTALLY-DEBLANK (EVROW)
  213.   (REM #'(LAMBDA (BLKSYM ENTRY)(AND (LISTP ENTRY)(EQ (CAR ENTRY) BLKSYM)))
  214.        *SPACING-INFO-SYMBOL* EVROW))
  215. (COMPILER:MAKE-OBSOLETE TOTALLY-DEBLANK
  216.             "You probably want to be using PARSE-LIST-FOR-EVAL instead. ")
  217.  
  218. (DEFUN REMOVE-SPACES-FROM-LEFT (LIST)
  219.   (MEM #'(LAMBDA (IGNORE X) (NOT (SPACES? X))) 'IGNORE LIST))
  220.  
  221. (DEFUN LEFT-JUSTIFY (EVROW)
  222.  (SETF (EVROW-ITEMS EVROW) (REMOVE-SPACES-FROM-LEFT (EVROW-ITEMS EVROW))))
  223.  
  224. (DEFUN ADD-SPACES-TO-RIGHT (LIST SPACES)
  225.   (APPEND LIST (NCONS (MAKE-SPACES SPACES))))
  226.  
  227. ;;;; Evaluator Interface
  228.  
  229. (DEFUN EVBOX-HAS-INPUTS? (EVBOX)
  230.   (MEMQ (GET-FIRST-ELEMENT-IN-EVROW (GET-FIRST-ROW-IN-EVBOX EVBOX)) *SYMBOLS-FOR-INPUT-LINE*))
  231.  
  232. (DEFUN GET-EVBOX-ROWS-FOR-EVAL (EVBOX)
  233.   (IF (EVBOX-HAS-INPUTS? EVBOX)
  234.       (CDR (EVBOX-ROW-ENTRIES EVBOX))
  235.       (EVBOX-ROW-ENTRIES EVBOX)))
  236.  
  237.  
  238.  
  239. ;;;; Getting useful info ABOUT Evboxes
  240.  
  241. (DEFUN EVROW-LENGTH-IN-ELEMENTS (EVROW)
  242.   (LENGTH (EVROW-ENTRIES EVROW)))
  243.  
  244. (DEFF EV-ROW-LENGTH-IN-ELEMENTS #'EVROW-LENGTH-IN-ELEMENTS)
  245. (COMPILER:MAKE-OBSOLETE EV-ROW-LENGTH-IN-ELEMENTS "Use EVROW-LENGTH-IN-ELEMENTS instead. ")
  246.  
  247. (DEFSUBST EVBOX-LENGTH-IN-ROWS (EVBOX)
  248.   (LENGTH (EVBOX-ROWS EVBOX)))
  249.  
  250. (DEFUN EVBOX-LENGTH-IN-ELEMENTS (EVBOX)
  251.   (LOOP FOR ROW IN (EVBOX-ROWS EVBOX)
  252.     SUMMING (EVROW-LENGTH-IN-ELEMENTS ROW)))
  253.  
  254. (DEFUN CHA-LENGTH-OF-EVROW-ITEM (ITEM)
  255.   (COND ((SPACES? ITEM) (GET-SPACES ITEM))
  256.     ((OR (EVBOX? ITEM) (BOX? ITEM) (EVPORT? ITEM)) 1)
  257.     ((NUMBERP ITEM) (STRING-LENGTH (FORMAT NIL "~A" ITEM)))    ;loses on *NOPOINT (sometimes)
  258.     ((LABEL-PAIR? ITEM) (+ (STRING-LENGTH (LABEL-PAIR-LABEL ITEM))
  259.                    (STRING-LENGTH (LABEL-PAIR-ELEMENT ITEM)) 1))
  260.     ((UNBOX-TOKEN? ITEM) (1+ (CHA-LENGTH-OF-EVROW-ITEM (UNBOX-TOKEN-ELEMENT ITEM))))
  261.     ((EVAL-IT-TOKEN? ITEM) (1+ (CHA-LENGTH-OF-EVROW-ITEM (EVAL-IT-TOKEN-ELEMENT ITEM))))
  262.     (T (STRING-LENGTH ITEM))))
  263.  
  264. (DEFSUBST ITEM-LIST-LENGTH-IN-CHAS (LIST)
  265.   (LOOP FOR ITEM IN LIST SUMMING (CHA-LENGTH-OF-EVROW-ITEM ITEM)))
  266.  
  267. (DEFUN EVROW-LENGTH-IN-CHAS (EVROW)
  268.   (ITEM-LIST-LENGTH-IN-CHAS (EVROW-ITEMS EVROW)))
  269.  
  270. (DEFF EV-ROW-LENGTH-IN-CHAS #'EVROW-LENGTH-IN-CHAS)
  271. (COMPILER:MAKE-OBSOLETE EV-ROW-LENGTH-IN-CHAS "Use EVROW-LENGTH-IN-CHAS instead. ")
  272.  
  273. (DEFUN EVROWS-MAX-LENGTH-IN-CHAS (ROWS)
  274.   (LOOP FOR ROW IN ROWS
  275.     MAXIMIZE (EVROW-LENGTH-IN-CHAS ROW)))
  276.  
  277. (DEFUN EVBOX-MAX-LENGTH-IN-CHAS (EVBOX)
  278.   (EVROWS-MAX-LENGTH-IN-CHAS (EVBOX-ROWS EVBOX)))
  279.  
  280. ;;; Stringifying
  281.  
  282. (DEFSUBST MAKE-BLANK-STRING (LENGTH)
  283.   (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING :INITIAL-VALUE #\SPACE)))
  284.  
  285. (DEFUN STRINGIFY (ITEM)
  286.   (COND ((SPACES? ITEM) (MAKE-BLANK-STRING (GET-SPACES ITEM)))
  287.     ((EVAL-BOX? ITEM) "[]")
  288.     ((NUMBERP ITEM) (FORMAT NIL "~A" ITEM))
  289.     ((LABEL-PAIR? ITEM)
  290.      (FORMAT NIL "~A:~A" (LABEL-PAIR-LABEL ITEM) (LABEL-PAIR-ELEMENT ITEM)))
  291.     ((UNBOX-TOKEN? ITEM) (FORMAT NIL "@~A" (UNBOX-TOKEN-ELEMENT ITEM)))
  292.     ((EVAL-IT-TOKEN? ITEM) (FORMAT NIL "!~A" (EVAL-IT-TOKEN-ELEMENT ITEM)))
  293.     ((AND (SYMBOLP ITEM) (GET ITEM 'CONVERTED-CHARACTER))
  294.      (FORMAT NIL "~C" (GET ITEM 'CONVERTED-CHARACTER)))
  295.     ((LISTP ITEM)
  296.      (LET ((RETURN-STRING ""))
  297.        (DOLIST (I ITEM)
  298.          (SETQ RETURN-STRING (STRING-APPEND RETURN-STRING (STRINGIFY I))))
  299.        RETURN-STRING))
  300.     (T (STRING ITEM))))
  301.  
  302. (DEFUN EVROW-TEXT-STRING (ROW)
  303.   (LET ((RETURN-STRING ""))
  304.     (DOLIST (ITEM (EVROW-ITEMS ROW))
  305.       (SETQ RETURN-STRING (STRING-APPEND RETURN-STRING (STRINGIFY ITEM))))
  306.     RETURN-STRING))
  307.  
  308. (DEFUN EVBOX-TEXT-STRING (BOX)
  309.   (DO* ((ROWS (EVBOX-ROWS BOX) (CDR ROWS))
  310.     (ROW (CAR ROWS))
  311.     (STRING ""))
  312.        ((NULL ROWS) STRING)
  313.     (SETQ STRING (STRING-APPEND STRING (EVROW-TEXT-STRING ROW)))
  314.     (UNLESS (EQ ROW (CAR ROWS))
  315.       (SETQ STRING (STRING-APPEND STRING (STRING #\CR))))))
  316.  
  317.  
  318.  
  319.  
  320. ;;;; Prebox selectors.  Return NIL when the element isn't there
  321. ;;;; Maybe these should all be SUBSTs ??
  322.  
  323. (DEFSUBST GET-NTH-ROW-IN-EVBOX (N EVBOX)
  324.   (NTH N (EVBOX-ROWS EVBOX)))
  325.  
  326. (DEFSUBST GET-FIRST-ROW-IN-EVBOX (EVBOX)
  327.   (CAR (EVBOX-ROWS EVBOX)))
  328.  
  329. (DEFSUBST GET-FIRST-ELEMENT-IN-EVROW (EVROW)
  330.   (CAR (EVROW-ENTRIES EVROW)))
  331.  
  332. (DEFSUBST GET-LAST-ELEMENT-IN-EVROW (EVROW)
  333.   (CAR (LAST (EVROW-ENTRIES EVROW))))
  334.  
  335. ;; 0 based
  336. (DEFUN GET-NTH-ELEMENT-IN-EVROW (N EVROW)
  337.   (NTH N  (EVROW-ENTRIES EVROW)))
  338.  
  339. (DEFSUBST REMOVE-FROM-LIST (N LIST)
  340.   (REMQ (NTH N LIST) LIST 1))
  341.  
  342. ;;; These CONS up a new rows (no side effects !!!)
  343.  
  344. (DEFUN GET-BUTNTH-ELEMENT-IN-EVROW (N EVROW)
  345.   (LET* ((ENTRIES (EVROW-ENTRIES EVROW))
  346.      (ITEM (NTH N ENTRIES)))
  347.     (MAKE-EVROW ENTRIES (REMOVE-FROM-LIST N ENTRIES)
  348.         ITEMS   (REMQ ITEM (EVROW-ITEMS EVROW) 1))))
  349.  
  350. (DEFSUBST GET-REST-ELEMENTS-IN-EVROW (EVROW)
  351.   (LET ((ENTRIES (EVROW-ENTRIES EVROW)))
  352.     (MAKE-EVROW ENTRIES (CDR ENTRIES)
  353.         ITEMS   (REMOVE-SPACES-FROM-LEFT
  354.               (CDR (MEMQ (CAR ENTRIES) (EVROW-ITEMS EVROW)))))))
  355.  
  356. (DEFSUBST GET-BUTLAST-ELEMENTS-IN-EVROW (EVROW)
  357.   (LET ((ENTRIES (EVROW-ENTRIES EVROW)))
  358.     (MAKE-EVROW ENTRIES (BUTLAST ENTRIES)
  359.         ITEMS   (REMQ (CAR (LAST ENTRIES)) (EVROW-ITEMS EVROW) 1))))
  360.  
  361. (DEFUN GET-EVBOX-ELEMENTS (EVBOX)
  362.   (LOOP FOR ROW-ENTRIES IN (EVBOX-ROW-ENTRIES EVBOX)
  363.     APPENDING ROW-ENTRIES))
  364.  
  365. ;;; EvBox mutators
  366.  
  367. (DEFUN SET-NTH-ROW-IN-EVBOX (N BOX NEW-ROW)
  368.   (LET ((ROWS (EVBOX-ROWS BOX)))
  369.     (SETF (NTH N ROWS) NEW-ROW)))
  370.  
  371. (DEFPROP GET-NTH-ROW-IN-EVBOX
  372.      ((GET-NTH-ROW-IN-EVBOX N EVBOX) SET-NTH-ROW-IN-EVBOX N EVBOX SI:VAL) SETF)
  373.  
  374. (DEFMACRO DELETE-NTH-ITEM-IN-EVROW (N EVROW)
  375.   `(LET ((ITEM (NTH ,N (EVROW-ENTRIES ,EVROW))))
  376.      (SPLICE-ITEM-OUT-OF-LIST (EVROW-ENTRIES ,EVROW) ITEM)
  377.      (SPLICE-ITEM-OUT-OF-LIST (EVROW-ITEMS   ,EVROW) ITEM)))
  378.  
  379. (DEFMACRO INSERT-NTH-ITEM-IN-EVROW (N EVROW NEW-ITEM)
  380.   `(PROGN
  381.      (SPLICE-ITEM-INTO-LIST-AT (EVROW-ENTRIES ,EVROW) ,NEW-ITEM ,N)
  382.      (SPLICE-ITEM-INTO-LIST-AT (EVROW-ITEMS   ,EVROW) ,NEW-ITEM
  383.                    (OR (FIND-POSITION-IN-LIST (NTH ,N (EVROW-ENTRIES ,EVROW))
  384.                               (EVROW-ITEMS ,EVROW))
  385.                    (LENGTH (EVROW-ITEMS ,EVROW))))))
  386.  
  387. (DEFMACRO CHANGE-NTH-ITEM-IN-EVROW (N EVROW NEW-ITEM)
  388.   `(LET ((ITEM (NTH ,N (EVROW-ENTRIES ,EVROW))))
  389.      (SPLICE-ITEM-INTO-LIST   (EVROW-ENTRIES ,EVROW) ,NEW-ITEM ITEM)
  390.      (SPLICE-ITEM-OUT-OF-LIST (EVROW-ENTRIES ,EVROW) ITEM)
  391.      (SPLICE-ITEM-INTO-LIST   (EVROW-ITEMS   ,EVROW) ,NEW-ITEM ITEM)
  392.      (SPLICE-ITEM-OUT-OF-LIST (EVROW-ITEMS   ,EVROW) ITEM)))
  393.  
  394. ;; CONSes up a new row, does NOT side effect
  395. (DEFF REMOVE-NTH-ITEM-IN-EVROW #'GET-BUTNTH-ELEMENT-IN-EVROW)
  396.   
  397. ;;;; Genericism...
  398.  
  399. ;;; Predicates
  400.  
  401. (DEFSUBST EVAL-NAMED? (THING)
  402.   (OR (AND (BOX? THING) (NAME-ROW? (TELL THING :NAME-ROW)))
  403.       (AND (OR (EVBOX? THING) (EVPORT? THING)) (NOT-NULL (EVBOX-NAME THING)))))
  404.  
  405. (DEFUN EVAL-EMPTY? (BOX)
  406.   (NOT (DOLIST (ROW (GET-BOX-ROWS BOX)) (UNLESS (NULL ROW) (RETURN T)))))
  407.  
  408. (DEFSUBST NUMBER-BOX? (BOX)
  409.   (AND (= 1 (GET-BOX-LENGTH-IN-ELEMENTS BOX)) (NUMBERP (GET-FIRST-ELEMENT BOX))))
  410.  
  411. (DEFUN NUMBERIZE (THING)
  412.   (COND ((NUMBERP THING) THING)
  413.     ((NUMBER-BOX? THING) (GET-FIRST-ELEMENT THING))
  414.     (T (FERROR "Can't convert ~A into a number. " THING))))
  415.  
  416. (DEFUN ELEMENT-EQUAL? (E1 E2)
  417.   (cond ((EQ (TOKEN-TYPE (ROW-ENTRY-ELEMENT E1)) (TOKEN-TYPE (ROW-ENTRY-ELEMENT E2)))
  418.      (COND ((EVAL-BOX? E1) (BOX-EQUAL? E1 E2))
  419.            ((NUMBERP E1) (= E1 E2))
  420.            (T (EQUAL E1 E2))))
  421.      ;; try and do the right thing for random lossage
  422.      ;; right now, this can arise from the CHARACTERS function which
  423.      ;; returns elements as strings in order to preserve CASE
  424.      ((and (eq (token-type e1) 'string)
  425.            (eq (token-type e2) 'symbol))
  426.       (string= e1 (string e2)))
  427.      ((and (eq (token-type e2) 'string)
  428.            (eq (token-type e1) 'symbol))
  429.       (string= (string e1) e2))
  430.      (t nil)))
  431.  
  432. (DEFUN ROW-EQUAL? (ROW1 ROW2)
  433.   (AND (= (LENGTH ROW1) (LENGTH ROW2))
  434.        (NOT (LOOP FOR E1 IN ROW1
  435.           FOR E2 IN ROW2
  436.           UNLESS (ELEMENT-EQUAL? E1 E2)
  437.             RETURN T))))
  438.  
  439. (DEFUN BOX-EQUAL? (BOX1 BOX2)
  440.   (LET ((ROWS1 (GET-BOX-ROWS BOX1))
  441.     (ROWS2 (GET-BOX-ROWS BOX2)))
  442.     (AND (= (LENGTH ROWS1) (LENGTH ROWS2))
  443.      (NOT (LOOP FOR ROW1 IN ROWS1
  444.             FOR ROW2 IN ROWS2
  445.             UNLESS (ROW-EQUAL? ROW1 ROW2)
  446.               RETURN T)))))
  447.  
  448. ;; Useful info
  449. (DEFUN GET-BOX-LENGTH-IN-ROWS (BOX-OR-PORT)
  450.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  451.     (COND ((port-box? box) (tell (tell box :ports) :length-in-rows))
  452.       ((BOX? BOX) (TELL BOX :LENGTH-IN-ROWS))
  453.       ((NUMBERP BOX) 1)
  454.       (T (EVBOX-LENGTH-IN-ROWS BOX)))))
  455.  
  456. (DEFUN GET-BOX-LENGTH-IN-ELEMENTS (BOX-OR-PORT)
  457.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  458.     (COND ((BOX? BOX) (LENGTH (TELL BOX :ELEMENTS)))
  459.       ((NUMBERP BOX) 1)
  460.       (T (EVBOX-LENGTH-IN-ELEMENTS BOX)))))
  461.  
  462. ;; Stringiness and stringosity
  463.  
  464. (DEFUN ROW-STRING (ROW)
  465.   (COND ((ROW? ROW) (TELL ROW :TEXT-STRING))
  466.     ((EVROW? ROW) (EVROW-TEXT-STRING ROW))
  467.     (T (FERROR "Can't coerce ~A into a string" ROW))))
  468.  
  469. (DEFUN TEXT-STRING (BOX-OR-PORT)
  470.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  471.     (COND ((EVBOX? BOX) (EVBOX-TEXT-STRING BOX))
  472.       ((NUMBERP BOX) (FORMAT NIL "~A" BOX))
  473.       ((BOX? BOX) (TELL BOX :TEXT-STRING))
  474.       (T (FERROR "DOn't know how to make a string from ~A" BOX)))))
  475.  
  476. ;; accessors for inner structure
  477.  
  478. (DEFUN GET-BOX-ROWS (BOX-OR-PORT &OPTIONAL (SPACES? NIL))
  479.   "Returns a list of rows which appear as a list of tokens"
  480.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  481.     (COND ((AND SPACES? (BOX? BOX))
  482.        (MAP-TELL (TELL BOX :ROWS) :ITEMS))
  483.       ((BOX? BOX)
  484.        (MAP-TELL (TELL BOX :ROWS) :ENTRIES))
  485.       ((NUMBERP BOX)
  486.        (NCONS (NCONS BOX)))
  487.       ((NULL SPACES?)
  488.        (EVBOX-ROW-ENTRIES BOX))
  489.       (T (EVBOX-ROW-ITEMS BOX)))))
  490.  
  491.  
  492. (DEFUN GET-NTH-ROW (N BOX-OR-PORT &OPTIONAL (SPACES? NIL))
  493.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  494.     (COND ((AND (NULL SPACES?) (BOX? BOX))
  495.        (TELL-CHECK-NIL (TELL BOX :ROW-AT-ROW-NO N) :ENTRIES))
  496.       ((BOX? BOX)
  497.        (TELL-CHECK-NIL (TELL BOX :ROW-AT-ROW-NO N) :ITEMS))
  498.       ((AND (NUMBERP BOX) (= 0 N)) (NCONS BOX))
  499.       ((NULL SPACES?)
  500.        (EVROW-ENTRIES (GET-NTH-ROW-IN-EVBOX N BOX)))
  501.       (T (EVROW-ITEMS (GET-NTH-ROW-IN-EVBOX N BOX))))))
  502.  
  503. (DEFUN GET-FIRST-ROW (BOX-OR-PORT &OPTIONAL (SPACES? NIL))
  504.   (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
  505.     (COND ((AND (NULL SPACES?) (BOX? BOX))
  506.        (TELL (TELL BOX :FIRST-INFERIOR-ROW) :ENTRIES))
  507.       ((BOX? BOX)
  508.        (TELL (TELL BOX :FIRST-INFERIOR-ROW) :ITEMS))
  509.       ((NUMBERP BOX) (NCONS BOX))
  510.       ((NULL SPACES?)
  511.        (EVROW-ENTRIES (GET-FIRST-ROW-IN-EVBOX BOX)))
  512.       (T (EVROW-ITEMS (GET-FIRST-ROW-IN-EVBOX BOX))))))
  513.  
  514. (DEFUN GET-FIRST-ELEMENT (BOX)
  515.   (IF (NUMBERP BOX) BOX
  516.       (DOTIMES (I (GET-BOX-LENGTH-IN-ROWS BOX))
  517.     (LET ((ENTRIES (GET-NTH-ROW I BOX)))
  518.       (WHEN (NOT (NULL ENTRIES)) (RETURN (CAR ENTRIES)))))))
  519.  
  520. (DEFUN GET-BOX-ELEMENTS (BOX)
  521.   (COND ((BOX? BOX) (TELL BOX :ELEMENTS))
  522.     (T (GET-EVBOX-ELEMENTS BOX))))
  523.  
  524. ;;; This port does not create back-pointers to the port so that the ports can be GC'd after
  525. ;;; the evaluation returns
  526.  
  527. (DEFUN PORT-TO-FOR-EVAL (TARGET &optional name-too)
  528.   (LET ((PORT (MAKE-INITIALIZED-BOX :TYPE 'PORT-BOX)))
  529.     (TELL PORT :SET-PORT-TO-BOX-FOR-EVAL TARGET)
  530.     (when (and name-too (not (null (box-name target))))
  531.       (tell port :set-name (make-name-row (list (box-name target)))))
  532.     PORT))
  533.  
  534. ;; this should make Evports but STREAMS have to be fixed to handled EvBoxes first...
  535. (DEFSUBST PORT-TO-INFERIORS-IN-LIST (LIST &optional name-too)
  536.   (MAPCAR #'(LAMBDA (X) (IF (EVAL-BOX? X) (PORT-TO-FOR-EVAL X name-too) X)) LIST))
  537.  
  538. (DEFUN PORT-TO-INFERIORS (EVROW)
  539.   "Makes an EVROW which replaces every BOX in the arg with a PORT to that BOX."
  540.   (MAKE-EVROW-FROM-ITEMS (PORT-TO-INFERIORS-IN-LIST (EVROW-ITEMS EVROW))))
  541.  
  542. ;;; mutators
  543.  
  544. ;; for ROWS (delete, insert and change)
  545. ;0 based
  546. (DEFUN DELETE-ROW-AT-ROW-NO (N BOX &OPTIONAL (NEW? NIL))
  547.   (COND ((NOT-NULL NEW?)
  548.      (LET ((ROWS (GET-BOX-ROWS BOX)))
  549.        (MAKE-EVDATA ROWS (APPEND (mapcar #'make-evrow-from-items (FIRSTN N ROWS))
  550.                      (mapcar #'make-evrow-from-items (NTHCDR (1+ N) ROWS))))))
  551.     ((BOX? BOX) (TELL BOX :DELETE-ROW-AT-ROW-NO N)
  552.      (TELL BOX :MODIFIED)
  553.      ':NOPRINT)
  554.     (T (SETF (EVBOX-ROWS BOX) (APPEND (FIRSTN N (EVBOX-ROWS BOX))
  555.                       (NTHCDR (1+ N) (EVBOX-ROWS BOX))))
  556.        ':NOPRINT)))
  557.  
  558. (DEFUN INSERT-ROW-AT-ROW-NO (N BOX NEW-ROW &OPTIONAL (NEW? NIL))
  559.   (COND ((NOT-NULL NEW?)
  560.      (LET ((ROWS (GET-BOX-ROWS BOX)))
  561.        (MAKE-EVDATA ROWS (APPEND (mapcar #'make-evrow-from-items (FIRSTN N ROWS))
  562.                      (NCONS NEW-ROW)
  563.                      (mapcar #'make-evrow-from-items (NTHCDR N ROWS))))))
  564.     ((BOX? BOX)
  565.      (TELL BOX :INSERT-ROW-AT-ROW-NO (MAKE-ROW (evrow-items NEW-ROW)) N)
  566.      (TELL BOX :MODIFIED)
  567.      ':NOPRINT)
  568.     (T (SETF (EVBOX-ROWS BOX)
  569.          (APPEND (FIRSTN N (EVBOX-ROWS BOX))
  570.              (NCONS NEW-ROW)
  571.              (NTHCDR N (EVBOX-ROWS BOX))))
  572.        ':NOPRINT)))
  573.  
  574. (DEFUN CHANGE-ROW-AT-ROW-NO (N BOX NEW-ROW &OPTIONAL (NEW? NIL))
  575.   (COND ((NOT-NULL NEW?)
  576.      (LET ((ROWS (GET-BOX-ROWS BOX)))
  577.        (MAKE-EVDATA ROWS (APPEND (mapcar #'make-evrow-from-items (FIRSTN N ROWS))
  578.                      (NCONS NEW-ROW)
  579.                      (mapcar #'make-evrow-from-items (NTHCDR (1+ N) ROWS))))))
  580.     ((BOX? BOX)
  581.      (TELL BOX :DELETE-ROW-AT-ROW-NO N)
  582.      (TELL BOX :INSERT-ROW-AT-ROW-NO (MAKE-ROW (evrow-items NEW-ROW)) N)
  583.      (TELL BOX :MODIFIED)
  584.      ':NOPRINT)
  585.     (T (SETF (EVBOX-ROWS BOX)
  586.          (APPEND (FIRSTN N (EVBOX-ROWS BOX))
  587.              (NCONS NEW-ROW)
  588.              (NTHCDR (1+ N) (EVBOX-ROWS BOX))))
  589.        ':NOPRINT)))
  590.  
  591. ;;; Useful interactions between character level and entry level representation
  592. ;;; these SIDE EFFECT
  593.  
  594. ;;; 0 based
  595.  
  596. ;; Since we lose some character information after READing (for example in a LABEL PAIR), we 
  597. ;; will sometimes need to look directly at the row on a character by character basis
  598. ;; these don't as yet handle nesting of compound items accurately e.g. (LABEL-PAIR (UNBOX...))
  599.  
  600. (DEFSUBST COMPOUND-ENTRY? (ENTRY)
  601.   "Returns T if the entry is allowed to have spaces within its visual representation. "
  602.   (OR (LABEL-PAIR? ENTRY) (UNBOX-TOKEN? ENTRY) (EVAL-IT-TOKEN? ENTRY)))
  603.  
  604. (DEFSUBST EXAMINE-ROW-CHARACTERS? (ENTRY)
  605.   "Returns T if the row entry's length cannot be determined from the entry itself. "
  606.   (OR (COMPOUND-ENTRY? ENTRY)            ; spaces within the pair are lost
  607.       (FIXP ENTRY)))                ; *NOPOINT lossage
  608.  
  609. (DEFSUBST COMPOUND-ENTRY-PROLOGUE-LENGTH (ENTRY)
  610.   (COND ((LABEL-PAIR? ENTRY) (CHA-LENGTH-OF-EVROW-ITEM (LABEL-PAIR-LABEL ENTRY)))
  611.     ;; assume that it is either an UNBOX or EVAL-IT token
  612.     (T 1)))
  613.  
  614. (DEFSUBST COMPOUND-ENTRY-EPILOGUE-LENGTH (ENTRY)
  615.   (COND ((LABEL-PAIR? ENTRY) (CHA-LENGTH-OF-EVROW-ITEM (LABEL-PAIR-ELEMENT ENTRY)))
  616.     ((UNBOX-TOKEN? ENTRY) (CHA-LENGTH-OF-EVROW-ITEM (UNBOX-TOKEN-ELEMENT ENTRY)))
  617.     ((EVAL-IT-TOKEN? ENTRY) (CHA-LENGTH-OF-EVROW-ITEM (EVAL-IT-TOKEN-ELEMENT ENTRY)))))
  618.  
  619. (DEFSUBST COMPOUND-ENTRY-INTERVENING-LENGTH (MID-NO ROW IGNORE-CHAS)
  620.   (LOOP FOR CHA-NO = MID-NO THEN (1+ CHA-NO)
  621.     FOR CHA    = (CHA-CODE (TELL ROW :CHA-AT-CHA-NO CHA-NO))
  622.     UNTIL (NOT (MEMBER CHA IGNORE-CHAS))
  623.     SUMMING 1))
  624.  
  625. (DEFSUBST COMPOUND-ENTRY-LENGTH (START-NO ROW ENTRY)
  626.   (LET ((PROLOGUE-LENGTH (COMPOUND-ENTRY-PROLOGUE-LENGTH ENTRY)))
  627.     (+ PROLOGUE-LENGTH
  628.        (COMPOUND-ENTRY-INTERVENING-LENGTH (+ START-NO PROLOGUE-LENGTH)
  629.                       ROW
  630.                       (IF (LABEL-PAIR? ENTRY) '(#\SPACE #\:) '(#\SPACE)))
  631.        (COMPOUND-ENTRY-EPILOGUE-LENGTH ENTRY))))
  632.  
  633. (DEFSUBST ACTUAL-CHA-LENGTH-OF-ENTRY (START-NO ROW ENTRY)
  634.   (IF (COMPOUND-ENTRY? ENTRY)
  635.       (COMPOUND-ENTRY-LENGTH START-NO ROW ENTRY)
  636.       (LOOP FOR CHA-NO = START-NO THEN (1+ CHA-NO)
  637.         FOR CHA = (TELL ROW :CHA-AT-CHA-NO CHA-NO)
  638.         UNTIL (EQUAL CHA #\SPACE)
  639.         SUMMING 1)))
  640.  
  641. (DEFUN GET-CHA-NOS-OF-ENTRY (ROW ENTRY-NO)
  642.   "Returns 2 values corresponding to the start and stop CHA-NO of the entry. "
  643.   (LOOP WITH ENTRY-INDEX = 0
  644.     WITH CHA-NO = 0
  645.     FOR ENTRY IN (TELL ROW :EVROW)
  646.     WHEN (AND (NOT (SPACES? ENTRY)) (= ENTRY-NO ENTRY-INDEX))
  647.       RETURN (VALUES CHA-NO (+ CHA-NO (IF (EXAMINE-ROW-CHARACTERS? ENTRY)
  648.                           (ACTUAL-CHA-LENGTH-OF-ENTRY CHA-NO ROW ENTRY)
  649.                           (CHA-LENGTH-OF-EVROW-ITEM ENTRY))))
  650.     UNLESS (SPACES? ENTRY)
  651.       DO (INCF ENTRY-INDEX)
  652.     DO (INCF CHA-NO (IF (EXAMINE-ROW-CHARACTERS? ENTRY)
  653.                 (ACTUAL-CHA-LENGTH-OF-ENTRY CHA-NO ROW ENTRY)
  654.                 (CHA-LENGTH-OF-EVROW-ITEM ENTRY)))
  655.     FINALLY
  656.       (FERROR "There are less than ~D entries in ~A" ENTRY-NO ROW)))
  657.  
  658. (DEFUN MAKE-ROW-WITH-PADDED-VALUE (THING &OPTIONAL (PAD-LEFT NIL) (PAD-RIGHT T))
  659.   (LET ((ROW (MAKE-ROW `(,THING))))
  660.     (WHEN PAD-LEFT (TELL ROW :INSERT-CHA-AT-CHA-NO #\SPACE 0))
  661.     (WHEN PAD-RIGHT (TELL ROW :APPEND-CHA #\SPACE))
  662.     ROW))
  663.  
  664. ;;; Row mutators for 
  665.  
  666. (DEFUN DELETE-ENTRY-IN-ROW-AT-ENTRY-NO (ROW ENTRY-NO)
  667.   (MULTIPLE-VALUE-BIND (START-CHA-NO STOP-CHA-NO)
  668.       (GET-CHA-NOS-OF-ENTRY ROW ENTRY-NO)
  669.     (TELL ROW :DELETE-CHAS-BETWEEN-CHA-NOS START-CHA-NO STOP-CHA-NO)))
  670.  
  671. (DEFUN INSERT-ENTRY-IN-ROW-AT-ENTRY-NO (ROW ENTRY-NO NEW-ENTRY)
  672.   (IF ( ENTRY-NO (LENGTH (TELL ROW :ENTRIES)))
  673.       (TELL ROW :INSERT-ROW-CHAS-AT-CHA-NO (MAKE-ROW-WITH-PADDED-VALUE NEW-ENTRY T)
  674.                                        (TELL ROW :LENGTH-IN-CHAS))
  675.       (TELL ROW :INSERT-ROW-CHAS-AT-CHA-NO (MAKE-ROW-WITH-PADDED-VALUE NEW-ENTRY)
  676.                                        (GET-CHA-NOS-OF-ENTRY ROW ENTRY-NO))))
  677.  
  678. (DEFUN CHANGE-ENTRY-IN-ROW-AT-ENTRY-NO   (ROW ENTRY-NO NEW-ENTRY)
  679.   (LET ((NEW-ROW (MAKE-ROW-WITH-PADDED-VALUE NEW-ENTRY)))
  680.     (MULTIPLE-VALUE-BIND (START-CHA-NO STOP-CHA-NO)
  681.     (GET-CHA-NOS-OF-ENTRY ROW ENTRY-NO)
  682.       (TELL ROW :DELETE-CHAS-BETWEEN-CHA-NOS START-CHA-NO STOP-CHA-NO)
  683.       (TELL ROW :INSERT-ROW-CHAS-AT-CHA-NO NEW-ROW START-CHA-NO))))
  684.  
  685. ;;; The actual mutators which other functions can call
  686. ;;; No bounds checking
  687.  
  688. (DEFUN DELETE-ITEM-AT-ITEM-NO-IN-ROW-NO (I R BOX &OPTIONAL (NEW? NIL))
  689.   (COND ((NOT-NULL NEW?)
  690.      (LET* ((ROWS (GET-BOX-ROWS BOX))
  691.         (row (get-nth-row r box)))
  692.        (MAKE-EVDATA-FROM-ROWS (APPEND (FIRSTN R ROWS)
  693.                      (NCONS (append (firstn i row) (nthcdr (1+ i) row)))
  694.                      (NTHCDR (1+ R) ROWS)))))
  695.     ((BOX? BOX)
  696.      (DELETE-ENTRY-IN-ROW-AT-ENTRY-NO (TELL BOX :ROW-AT-ROW-NO R) I)
  697.      ':NOPRINT)
  698.     (T (DELETE-NTH-ITEM-IN-EVROW I (GET-NTH-ROW-IN-EVBOX R BOX))
  699.        ':NOPRINT)))
  700.  
  701. (DEFUN INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (I R BOX NEW-ITEM &OPTIONAL (NEW? NIL))
  702.   (COND ((NOT-NULL NEW?)
  703.      (LET* ((ROWS (GET-BOX-ROWS BOX))
  704.         (ROW (GET-NTH-ROW R BOX)))
  705.        (MAKE-EVDATA-FROM-ROWS (APPEND (FIRSTN R ROWS)
  706.                      (NCONS (APPEND (FIRSTN I ROW) (NCONS NEW-ITEM)
  707.                             (NTHCDR I ROW)))
  708.                      (NTHCDR (1+ R) ROWS)))))
  709.     ((BOX? BOX)
  710.      (INSERT-ENTRY-IN-ROW-AT-ENTRY-NO (TELL BOX :ROW-AT-ROW-NO R) I NEW-ITEM)
  711.      ':NOPRINT)
  712.     (T (INSERT-NTH-ITEM-IN-EVROW I (GET-NTH-ROW-IN-EVBOX R BOX) NEW-ITEM)
  713.        ':NOPRINT)))
  714.  
  715. (DEFUN CHANGE-ITEM-AT-ITEM-NO-IN-ROW-NO (I R BOX NEW-ITEM &OPTIONAL (NEW? NIL))
  716.   (COND ((NOT-NULL NEW?)
  717.      (LET* ((ROWS (GET-BOX-ROWS BOX))
  718.         (ROW (GET-NTH-ROW R BOX)))
  719.        (MAKE-EVDATA-FROM-ROWS (APPEND (FIRSTN R ROWS)
  720.                      (NCONS (APPEND (FIRSTN I ROW) (NCONS NEW-ITEM)
  721.                             (NTHCDR (1+ I) ROW)))
  722.                      (NTHCDR (1+ R) ROWS)))))
  723.     ((BOX? BOX)
  724.      (CHANGE-ENTRY-IN-ROW-AT-ENTRY-NO (TELL BOX :ROW-AT-ROW-NO R) I NEW-ITEM)
  725.      ':NOPRINT)
  726.     (T (CHANGE-NTH-ITEM-IN-EVROW I (GET-NTH-ROW-IN-EVBOX R BOX) NEW-ITEM)
  727.        ':NOPRINT)))
  728.  
  729. (DEFUN GET-ROW-AND-COL-NUMBER (N BOX)
  730.   "Converts 1-based GET-NTH coordinates into 0-based GET-RC coordinates.  Values returned are row number and column number"
  731.   (DECLARE (VALUES ROW-NO INDEX))
  732.   (LOOP WITH INDEX = (1- N)
  733.     FOR ROW IN (GET-BOX-ROWS BOX)
  734.     FOR ROW-NO = 0 THEN (1+ ROW-NO)
  735.     FOR LENGTH = (LENGTH ROW)
  736.     WHEN (< INDEX LENGTH)
  737.       RETURN (VALUES ROW-NO INDEX)
  738.     DO (SETQ INDEX (- INDEX LENGTH))))
  739.  
  740. ;;; gets the whitespace out (you try scrubbing them out....)
  741. (DEFUN TRIM-EMPTY-ROWS (LIST-OF-ROWS)
  742.   (LOOP FOR ROW IN LIST-OF-ROWS
  743.     UNLESS (NULL (SUBSET-NOT #'SPACES? (EVROW-ITEMS ROW)))
  744.       COLLECT ROW INTO NEW-ROWS
  745.     FINALLY
  746.       (RETURN (IF (NULL NEW-ROWS) `(,(MAKE-EMPTY-EVROW)) NEW-ROWS))))
  747.